home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy-1.1 (sources only) / mindy-1.1 / interp / instance.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-08-23  |  48.3 KB  |  1,786 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: instance.c,v 1.23 94/08/22 22:36:19 wlott Exp $
  27. *
  28. * This file implements instances and user defined classes.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include <stdio.h>
  33.  
  34. #include "mindy.h"
  35. #include "gc.h"
  36. #include "obj.h"
  37. #include "class.h"
  38. #include "list.h"
  39. #include "vec.h"
  40. #include "type.h"
  41. #include "bool.h"
  42. #include "module.h"
  43. #include "num.h"
  44. #include "thread.h"
  45. #include "func.h"
  46. #include "sym.h"
  47. #include "value.h"
  48. #include "error.h"
  49. #include "driver.h"
  50. #include "def.h"
  51. #include "print.h"
  52. #include "instance.h"
  53.  
  54. struct defined_class {
  55.     obj_t class;
  56.     enum type_Id type_id;
  57.     boolean abstract_p;
  58.     boolean sealed_p;
  59.     struct library *library;
  60.     int (*scavenge)(struct object *ptr);
  61.     obj_t (*transport)(obj_t object);
  62.     void (*print)(obj_t object);
  63.     obj_t debug_name;
  64.     obj_t superclasses;
  65.     obj_t cpl;
  66.     obj_t direct_subclasses;
  67.     obj_t all_subclasses;
  68.  
  69.     obj_t new_slots;
  70.     obj_t all_slots;
  71.     obj_t new_initargs;
  72.     obj_t all_initargs;
  73.     obj_t inheriteds;
  74.  
  75.     obj_t instance_positions;
  76.     int instance_length;
  77.     obj_t instance_layout;
  78.  
  79.     obj_t subclass_positions;
  80.     obj_t subclass_slots;
  81.     obj_t subclass_layout;
  82. };
  83.  
  84. #define DC(o) obj_ptr(struct defined_class *, o)
  85.  
  86. struct slot_descr {
  87.     obj_t class;
  88.     obj_t name;
  89.     enum slot_allocation alloc;
  90.     obj_t creator;
  91.     obj_t init_function_or_value;
  92.     boolean init_function_p;
  93.     obj_t init_keyword;
  94.     boolean keyword_required;
  95.     obj_t getter;
  96.     obj_t getter_method;
  97.     obj_t setter;
  98.     obj_t setter_method;
  99.     obj_t type;
  100.     int desired_offset;
  101.     boolean ever_missed;
  102. };
  103.  
  104. #define SD(o) obj_ptr(struct slot_descr *, o)
  105.  
  106. struct initarg_descr {
  107.     obj_t class;
  108.     obj_t keyword;
  109.     boolean required_p;
  110.     obj_t type;
  111.     obj_t init_function_or_value;
  112.     boolean init_function_p;
  113.     obj_t initializer;
  114. };
  115.  
  116. #define INTD(o) obj_ptr(struct initarg_descr *, o)
  117.  
  118. struct inherited_descr {
  119.     obj_t class;
  120.     obj_t name;
  121.     obj_t init_function_or_value;
  122.     boolean init_function_p;
  123. };
  124.  
  125. #define INHD(o) obj_ptr(struct inherited_descr *, o)
  126.  
  127. struct postable {
  128.     obj_t class;
  129.     obj_t alist;
  130. };
  131.  
  132. #define PT(o) obj_ptr(struct postable *, o)
  133.  
  134. enum initializer_kind { slot_Initializer, initarg_slot_Initializer,
  135.             initarg_Initializer, inherited_Initializer };
  136.  
  137. struct initializer {
  138.     obj_t class;
  139.     enum initializer_kind kind;
  140.     obj_t slot;
  141.     obj_t initarg;
  142.     obj_t inherited;
  143. };
  144.  
  145. #define INITIALIZER(o) obj_ptr(struct initializer *, o)
  146.  
  147. struct instance {
  148.     obj_t class;
  149.     obj_t slots[0];
  150. };
  151.  
  152. #define INST(o) obj_ptr(struct instance *, o)
  153.  
  154. static obj_t obj_DefinedClassClass = NULL;
  155. static obj_t obj_SlotDescrClass = NULL;
  156. static obj_t obj_InitargDescrClass = NULL;
  157. static obj_t obj_InheritedDescrClass = NULL;
  158. static obj_t obj_PosTableClass = NULL;
  159. static obj_t obj_InitializerClass = NULL;
  160.  
  161.  
  162. /* Accessor methods. */
  163.  
  164. static int find_position(obj_t pt, obj_t slot);
  165.  
  166. static void slow_instance_getter(obj_t method, struct thread *thread,
  167.                  obj_t *args)
  168. {
  169.     obj_t datum = accessor_method_datum(method);
  170.     obj_t *old_sp = args-1;
  171.     obj_t instance = args[0];
  172.     obj_t class = INST(instance)->class;
  173.     int index = find_position(DC(class)->instance_positions, datum);
  174.     obj_t value = INST(instance)->slots[index];
  175.  
  176.     if (value == obj_Unbound) {
  177.     push_linkage(thread, args);
  178.     error("Unbound slot.");
  179.     }
  180.  
  181.     *old_sp = value;
  182.     thread->sp = args;
  183.     do_return(thread, old_sp, old_sp);
  184. }
  185.  
  186. static void fast_instance_getter(obj_t method, struct thread *thread,
  187.                  obj_t *args)
  188. {
  189.     obj_t datum = accessor_method_datum(method);
  190.     obj_t *old_sp = args-1;
  191.     obj_t instance = args[0];
  192.     obj_t value = INST(instance)->slots[fixnum_value(datum)];
  193.  
  194.     if (value == obj_Unbound) {
  195.     push_linkage(thread, args);
  196.     error("Unbound slot.");
  197.     }
  198.  
  199.     *old_sp = value;
  200.     thread->sp = args;
  201.     do_return(thread, old_sp, old_sp);
  202. }
  203.  
  204. static void slow_instance_setter(obj_t method, struct thread *thread,
  205.                  obj_t *args)
  206. {
  207.     obj_t datum = accessor_method_datum(method);
  208.     obj_t *old_sp = args-1;
  209.     obj_t value = args[0];
  210.     obj_t instance = args[1];
  211.     obj_t class = INST(instance)->class;
  212.     int index = find_position(DC(class)->instance_positions, datum);
  213.  
  214.     INST(instance)->slots[index] = value;
  215.  
  216.     *old_sp = value;
  217.     thread->sp = args;
  218.     do_return(thread, old_sp, old_sp);
  219. }
  220.  
  221. static void fast_instance_setter(obj_t method, struct thread *thread,
  222.                  obj_t *args)
  223. {
  224.     obj_t datum = accessor_method_datum(method);
  225.     obj_t *old_sp = args-1;
  226.     obj_t value = args[0];
  227.     obj_t instance = args[1];
  228.  
  229.     INST(instance)->slots[fixnum_value(datum)] = value;
  230.  
  231.     *old_sp = value;
  232.     thread->sp = args;
  233.     do_return(thread, old_sp, old_sp);
  234. }
  235.  
  236. static void slow_subclass_getter(obj_t method, struct thread *thread,
  237.                  obj_t *args)
  238. {
  239.     obj_t datum = accessor_method_datum(method);
  240.     obj_t *old_sp = args-1;
  241.     obj_t instance = args[0];
  242.     obj_t class = INST(instance)->class;
  243.     int index = find_position(DC(class)->subclass_positions, datum);
  244.     obj_t value = SOVEC(DC(class)->subclass_slots)->contents[index];
  245.  
  246.     if (value == obj_Unbound) {
  247.     push_linkage(thread, args);
  248.     error("Unbound slot.");
  249.     }
  250.  
  251.     *old_sp = value;
  252.     thread->sp = args;
  253.     do_return(thread, old_sp, old_sp);
  254. }
  255.  
  256. static void fast_subclass_getter(obj_t method, struct thread *thread,
  257.                  obj_t *args)
  258. {
  259.     obj_t datum = accessor_method_datum(method);
  260.     obj_t *old_sp = args-1;
  261.     obj_t instance = args[0];
  262.     obj_t class = INST(instance)->class;
  263.     int index = fixnum_value(datum);
  264.     obj_t value = SOVEC(DC(class)->subclass_slots)->contents[index];
  265.  
  266.     if (value == obj_Unbound) {
  267.     push_linkage(thread, args);
  268.     error("Unbound slot.");
  269.     }
  270.  
  271.     *old_sp = value;
  272.     thread->sp = args;
  273.     do_return(thread, old_sp, old_sp);
  274. }
  275.  
  276. static void slow_subclass_setter(obj_t method, struct thread *thread,
  277.                  obj_t *args)
  278. {
  279.     obj_t datum = accessor_method_datum(method);
  280.     obj_t *old_sp = args-1;
  281.     obj_t value = args[0];
  282.     obj_t instance = args[1];
  283.     obj_t class = INST(instance)->class;
  284.     int index = find_position(DC(class)->subclass_positions, datum);
  285.  
  286.     SOVEC(DC(class)->subclass_slots)->contents[index] = value;
  287.  
  288.     *old_sp = value;
  289.     thread->sp = args;
  290.     do_return(thread, old_sp, old_sp);
  291. }
  292.  
  293. static void fast_subclass_setter(obj_t method, struct thread *thread,
  294.                  obj_t *args)
  295. {
  296.     obj_t datum = accessor_method_datum(method);
  297.     obj_t *old_sp = args-1;
  298.     obj_t value = args[0];
  299.     obj_t instance = args[1];
  300.     obj_t class = INST(instance)->class;
  301.     int index = fixnum_value(datum);
  302.  
  303.     SOVEC(DC(class)->subclass_slots)->contents[index] = value;
  304.  
  305.     *old_sp = value;
  306.     thread->sp = args;
  307.     do_return(thread, old_sp, old_sp);
  308. }
  309.  
  310. static void class_getter(obj_t method, struct thread *thread, obj_t *args)
  311. {
  312.     obj_t datum = accessor_method_datum(method);
  313.     obj_t *old_sp = args-1;
  314.     obj_t value = value_cell_ref(datum);
  315.  
  316.     if (value == obj_Unbound) {
  317.     push_linkage(thread, args);
  318.     error("Unbound slot.");
  319.     }
  320.  
  321.     *old_sp = value;
  322.     thread->sp = args;
  323.     do_return(thread, old_sp, old_sp);
  324. }
  325.  
  326. static void class_setter(obj_t method, struct thread *thread, obj_t *args)
  327. {
  328.     obj_t datum = accessor_method_datum(method);
  329.     obj_t *old_sp = args-1;
  330.     obj_t value = args[0];
  331.  
  332.     value_cell_set(datum, value);
  333.  
  334.     *old_sp = value;
  335.     thread->sp = args;
  336.     do_return(thread, old_sp, old_sp);
  337. }
  338.  
  339. static void constant_getter(obj_t method, struct thread *thread, obj_t *args)
  340. {
  341.     obj_t value = accessor_method_datum(method);
  342.     obj_t *old_sp = args-1;
  343.  
  344.     *old_sp = value;
  345.     thread->sp = args;
  346.     do_return(thread, old_sp, old_sp);
  347. }
  348.  
  349.  
  350.  
  351. /* Position tables. */
  352.  
  353. static obj_t make_position_table(void)
  354. {
  355.     obj_t res = alloc(obj_PosTableClass, sizeof(struct postable));
  356.  
  357.     PT(res)->alist = obj_Nil;
  358.  
  359.     return res;
  360. }
  361.  
  362. static void note_position(obj_t table, obj_t slot, int index)
  363. {
  364.     PT(table)->alist = pair(pair(slot, make_fixnum(index)), PT(table)->alist);
  365.  
  366.     if (!SD(slot)->ever_missed) {
  367.     SD(slot)->ever_missed = TRUE;
  368.     switch (SD(slot)->alloc) {
  369.       case alloc_INSTANCE:
  370.         set_method_iep(SD(slot)->getter_method, slow_instance_getter);
  371.         set_accessor_method_datum(SD(slot)->getter_method, slot);
  372.         if (SD(slot)->setter_method != obj_False) {
  373.         set_method_iep(SD(slot)->setter_method, slow_instance_setter);
  374.         set_accessor_method_datum(SD(slot)->setter_method, slot);
  375.         }
  376.         break;
  377.  
  378.       case alloc_SUBCLASS:
  379.         set_method_iep(SD(slot)->getter_method, slow_subclass_getter);
  380.         set_accessor_method_datum(SD(slot)->getter_method, slot);
  381.         if (SD(slot)->setter_method != obj_False) {
  382.         set_method_iep(SD(slot)->setter_method, slow_subclass_setter);
  383.         set_accessor_method_datum(SD(slot)->setter_method, slot);
  384.         }
  385.         break;
  386.  
  387.       default:
  388.         lose("Displacing a slot with allocation other than "
  389.          "instance or subclass?");
  390.         break;
  391.     }
  392.     }
  393. }
  394.  
  395. static int find_position(obj_t pt, obj_t slot)
  396. {
  397.     obj_t scan;
  398.  
  399.     if (pt != obj_False) {
  400.     for (scan = PT(pt)->alist; scan != obj_Nil; scan = TAIL(scan)) {
  401.         obj_t entry = HEAD(scan);
  402.  
  403.         if (HEAD(entry) == slot)
  404.         return fixnum_value(TAIL(entry));
  405.     }
  406.     }
  407.     return SD(slot)->desired_offset;
  408. }
  409.  
  410.  
  411. /* Slot descriptors. */
  412.  
  413. static obj_t make_slot_descriptor(obj_t name, obj_t allocation,
  414.                   obj_t getter, obj_t setter, obj_t type,
  415.                   obj_t init_keyword, obj_t req_init_keyword,
  416.                   obj_t init_function, obj_t init_value)
  417. {
  418.     obj_t res = alloc(obj_SlotDescrClass, sizeof(struct slot_descr));
  419.     enum slot_allocation alloc
  420.     = (enum slot_allocation)fixnum_value(allocation);
  421.  
  422.     SD(res)->name = name;
  423.     SD(res)->alloc = alloc;
  424.     SD(res)->creator = obj_False;
  425.     if (alloc == alloc_CONSTANT) {
  426.     if (init_value == obj_Unbound)
  427.         error("CONSTANT slots must have an init-value:");
  428.     if (req_init_keyword != obj_False)
  429.         error("Can't use required-init-keyword: in constant slots.");
  430.     if (init_keyword != obj_False)
  431.         error("Can't use init-keyword: in constant slots.");
  432.     }
  433.     if (init_function != obj_Unbound) {
  434.     if (init_value != obj_Unbound)
  435.         error("Can't specify both an init-function: and an init-value:");
  436.     SD(res)->init_function_or_value = init_function;
  437.     SD(res)->init_function_p = TRUE;
  438.     }
  439.     else {
  440.     if (init_value != obj_Unbound && type != obj_False)
  441.         check_type(init_value, type);
  442.     SD(res)->init_function_or_value = init_value;
  443.     SD(res)->init_function_p = FALSE;
  444.     }
  445.     if (req_init_keyword != obj_False) {
  446.     if (init_function != obj_Unbound)
  447.         error("Can't mix required-init-keyword: and init-function:");
  448.     if (init_value != obj_Unbound)
  449.         error("Can't mix required-init-keyword: and init-value:");
  450.     if (init_keyword != obj_False)
  451.         error("Can't mix required-init-keyword: and init-keyword:");
  452.     SD(res)->init_keyword = req_init_keyword;
  453.     SD(res)->keyword_required = TRUE;
  454.     }
  455.     else {
  456.     SD(res)->init_keyword = init_keyword;
  457.     SD(res)->keyword_required = FALSE;
  458.     }
  459.     SD(res)->getter = getter;
  460.     SD(res)->getter_method = obj_False;
  461.     SD(res)->setter = setter;
  462.     SD(res)->setter_method = obj_False;
  463.     if (type == obj_False)
  464.     SD(res)->type = obj_ObjectClass;
  465.     else
  466.     SD(res)->type = type;
  467.     SD(res)->desired_offset = -1;
  468.     SD(res)->ever_missed = FALSE;
  469.  
  470.     return res;
  471. }
  472.  
  473. /* Initarg Descriptors */
  474.  
  475. static obj_t make_initarg_descr(obj_t keyword, obj_t required, obj_t type,
  476.                 obj_t init_function, obj_t init_value)
  477. {
  478.     obj_t res = alloc(obj_InitargDescrClass, sizeof(struct initarg_descr));
  479.  
  480.     INTD(res)->keyword = keyword;
  481.     if (required != obj_False) {
  482.     if (init_function != obj_Unbound || init_value != obj_Unbound)
  483.         error("Can't specify initial value for required init arg.");
  484.     INTD(res)->required_p = TRUE;
  485.     }
  486.     else {
  487.         INTD(res)->required_p = FALSE;
  488.     }
  489.     if (type == obj_False) {
  490.         INTD(res)->type = obj_ObjectClass;
  491.     }
  492.     else {
  493.         INTD(res)->type = type;
  494.     }
  495.     if (init_function != obj_Unbound) {
  496.     if (init_value != obj_Unbound)
  497.         error("Can't specify both an init-function: and an init-value:");
  498.     INTD(res)->init_function_or_value = init_function;
  499.     INTD(res)->init_function_p = TRUE;
  500.     }
  501.     else {
  502.     INTD(res)->init_function_or_value = init_value;
  503.     INTD(res)->init_function_p = FALSE;
  504.     }
  505.     INTD(res)->initializer = obj_False;
  506.  
  507.     return res;
  508. }
  509.  
  510. /* Inherited Descriptors */
  511.  
  512. static obj_t make_inherited_descr(obj_t name,
  513.                   obj_t init_function, obj_t init_value)
  514. {
  515.     obj_t res = alloc(obj_InheritedDescrClass, sizeof(struct inherited_descr));
  516.  
  517.     INHD(res)->name = name;
  518.     if (init_function != obj_Unbound) {
  519.     if (init_value != obj_Unbound)
  520.         error("Can't specify both an init-function: and an init-value:");
  521.     INHD(res)->init_function_or_value = init_function;
  522.     INHD(res)->init_function_p = TRUE;
  523.     }
  524.     else {
  525.     INHD(res)->init_function_or_value = init_value;
  526.     INHD(res)->init_function_p = FALSE;
  527.     }
  528.  
  529.     return res;
  530. }
  531.  
  532.  
  533. /* Initializers */
  534.  
  535. static struct variable *initialize_gf_variable = NULL;
  536.  
  537. static obj_t make_initializer(enum initializer_kind kind, obj_t slot,
  538.                   obj_t initarg, obj_t inherited)
  539. {
  540.     obj_t res = alloc(obj_InitializerClass, sizeof(struct initializer));
  541.  
  542.     INITIALIZER(res)->kind = kind;
  543.     INITIALIZER(res)->slot = slot;
  544.     INITIALIZER(res)->initarg = initarg;
  545.     INITIALIZER(res)->inherited = inherited;
  546.  
  547.     return res;
  548. }
  549.  
  550. static obj_t slot_initializer(obj_t slot)
  551. {
  552.     return make_initializer(slot_Initializer, slot,
  553.                 obj_False, obj_False);
  554. }
  555.  
  556. static obj_t initarg_slot_initializer(obj_t slot, obj_t initarg)
  557. {
  558.     return make_initializer(initarg_slot_Initializer, slot,
  559.                 initarg, obj_False);
  560. }
  561.  
  562. static obj_t initarg_initializer(obj_t initarg)
  563. {
  564.     return make_initializer(initarg_Initializer, obj_False,
  565.                 initarg, obj_False);
  566. }
  567.  
  568. static obj_t inherited_initializer(obj_t slot, obj_t inherited)
  569. {
  570.     return make_initializer(inherited_Initializer, slot,
  571.                 obj_False, inherited);
  572. }
  573.  
  574. static boolean initializer_init_function_p(obj_t initializer)
  575. {
  576.     switch (INITIALIZER(initializer)->kind) {
  577.       case slot_Initializer:
  578.     return SD(INITIALIZER(initializer)->slot)->init_function_p;
  579.     break;
  580.       case initarg_slot_Initializer:
  581.     return INTD(INITIALIZER(initializer)->initarg)->init_function_p;
  582.     break;
  583.       case initarg_Initializer:
  584.     return INTD(INITIALIZER(initializer)->initarg)->init_function_p;
  585.     break;
  586.       case inherited_Initializer:
  587.     return INHD(INITIALIZER(initializer)->inherited)->init_function_p;
  588.     break;
  589.       default:
  590.     lose("Tried to get init_function_p from strange initializer.");
  591.     return FALSE;
  592.     }
  593. }
  594.  
  595. static obj_t initializer_init_function_or_value(obj_t initializer)
  596. {
  597.     switch (INITIALIZER(initializer)->kind) {
  598.       case slot_Initializer:
  599.     return SD(INITIALIZER(initializer)->slot)->init_function_or_value;
  600.     break;
  601.       case initarg_slot_Initializer:
  602.     return INTD(INITIALIZER(initializer)->initarg)->init_function_or_value;
  603.     break;
  604.       case initarg_Initializer:
  605.     return INTD(INITIALIZER(initializer)->initarg)->init_function_or_value;
  606.     break;
  607.       case inherited_Initializer:
  608.     return INHD(INITIALIZER(initializer)->inherited)->init_function_or_value;
  609.     break;
  610.       default:
  611.     lose("Tried to get init_function_or_value from strange initializer.");
  612.     return NULL;
  613.     }
  614. }
  615.  
  616. static void do_finish_initialization(struct thread *thread, obj_t *vals)
  617. {
  618.     obj_t inst_or_class = vals[-3];
  619.     obj_t *old_sp = pop_linkage(thread);
  620.  
  621.     *old_sp = inst_or_class;
  622.     thread->sp = old_sp + 1;
  623.  
  624.     do_return(thread, old_sp, old_sp);
  625. }
  626.  
  627. static void do_init_value(struct thread *thread, obj_t *vals);
  628.  
  629. static void do_initializers(struct thread *thread, obj_t initializers)
  630. {
  631.     obj_t *sp = thread->sp;
  632.  
  633.     /* If there are initializers left, get the init-value or call the
  634.        init-function, and give the value to do_init_value.
  635.  
  636.        If there are no initializers left, call the Dylan initialize
  637.        function with the defaulted initargs. */
  638.  
  639.     if (initializers != obj_Nil) {
  640.     obj_t initializer = HEAD(initializers);
  641.  
  642.     sp[-1] = initializers;
  643.     sp[0] = initializer_init_function_or_value(initializer);
  644.     thread->sp = sp + 1;
  645.     if (initializer_init_function_p(initializer)) {
  646.         set_c_continuation(thread, do_init_value);
  647.         invoke(thread, 0);
  648.     }
  649.     else {
  650.         do_init_value(thread, sp);
  651.     }
  652.     }
  653.     else {
  654.     obj_t inst_or_class = sp[-3];
  655.     obj_t initargs = sp[-2];
  656.     int nargs;
  657.  
  658.     *sp++ = initialize_gf_variable->value;
  659.     *sp++ = inst_or_class;
  660.     for ( ; initargs != obj_Nil; initargs = TAIL(initargs)) {
  661.         obj_t initarg = HEAD(initargs);
  662.         *sp++ = INTD(initarg)->keyword;
  663.         *sp++ = INTD(initarg)->init_function_or_value;
  664.     }
  665.     nargs = sp - thread->sp - 1;
  666.     thread->sp = sp;
  667.  
  668.     set_c_continuation(thread, do_finish_initialization);
  669.     invoke(thread, nargs);
  670.     }
  671. }
  672.  
  673. static void do_init_value(struct thread *thread, obj_t *vals)
  674. {
  675.     obj_t inst_or_class = vals[-3];
  676.     obj_t initializers = vals[-1];
  677.     obj_t initializer = HEAD(initializers);
  678.     obj_t value;
  679.     obj_t slot;
  680.     int index;
  681.     obj_t initarg;
  682.  
  683.     if (thread->sp == vals)
  684.     value = obj_False;
  685.     else {
  686.     value = vals[0];
  687.     thread->sp = vals;
  688.     }
  689.  
  690.     /* Initialize a slot if necessary */
  691.  
  692.     if (obj_ptr(struct object *, inst_or_class)->class
  693.       == obj_DefinedClassClass) {
  694.     obj_t class = inst_or_class;
  695.  
  696.     switch (INITIALIZER(initializer)->kind) {
  697.       case slot_Initializer:
  698.       case initarg_slot_Initializer:
  699.       case inherited_Initializer:
  700.         slot = INITIALIZER(initializer)->slot;
  701.         if (value != obj_Unbound && !instancep(value, SD(slot)->type))
  702.         type_error(value, SD(slot)->type);
  703.         switch (SD(slot)->alloc) {
  704.           case alloc_SUBCLASS:
  705.         index = find_position(DC(class)->subclass_positions, slot);
  706.         SOVEC(DC(class)->subclass_slots)->contents[index] = value;
  707.         break;
  708.           case alloc_CLASS:
  709.         value_cell_set(accessor_method_datum(SD(slot)->getter_method),
  710.                    value);
  711.         break;
  712.           default:
  713.         lose("Tried to initialize a strange kind of class slot.");
  714.         }
  715.         break;
  716.       case initarg_Initializer:
  717.         break;
  718.       default:
  719.         lose("Strange kind of initializer.");
  720.     }
  721.     }
  722.     else {
  723.     obj_t instance = inst_or_class;
  724.     obj_t class = INST(instance)->class;
  725.  
  726.     switch (INITIALIZER(initializer)->kind) {
  727.       case slot_Initializer:
  728.       case initarg_slot_Initializer:
  729.       case inherited_Initializer:
  730.         slot = INITIALIZER(initializer)->slot;
  731.         if (value != obj_Unbound && !instancep(value, SD(slot)->type))
  732.             type_error(value, SD(slot)->type);
  733.         switch (SD(slot)->alloc) {
  734.           case alloc_INSTANCE:
  735.         index = find_position(DC(class)->instance_positions, slot);
  736.         INST(instance)->slots[index] = value;
  737.         break;
  738.           case alloc_SUBCLASS:
  739.         index = find_position(DC(class)->subclass_positions, slot);
  740.         SOVEC(DC(class)->subclass_slots)->contents[index] = value;
  741.         break;
  742.           case alloc_CLASS:
  743.         value_cell_set(accessor_method_datum(SD(slot)->getter_method),
  744.                    value);
  745.         break;
  746.           default:
  747.         lose("Tried to initialize a strange kind of instance slot.");
  748.         }
  749.         break;
  750.       case initarg_Initializer:
  751.         break;
  752.       default:
  753.         lose("Strange kind of initializer.");
  754.     }
  755.     }
  756.  
  757.     /* Initialize an initarg if necessary */
  758.  
  759.     switch (INITIALIZER(initializer)->kind) {
  760.       case initarg_slot_Initializer:
  761.       case initarg_Initializer:
  762.     initarg = INITIALIZER(initializer)->initarg;
  763.     if (value != obj_Unbound && !instancep(value, INTD(initarg)->type))
  764.         type_error(value, INTD(initarg)->type);
  765.     INTD(initarg)->init_function_or_value = value;
  766.     INTD(initarg)->init_function_p = FALSE;
  767.     break;
  768.       case slot_Initializer:
  769.       case inherited_Initializer:
  770.     break;
  771.       default:
  772.     lose("Strange kind of initializer.");
  773.     }
  774.  
  775.     do_initializers(thread, TAIL(initializers));
  776. }
  777.  
  778. static void do_initialization(obj_t inst_or_class, obj_t initargs,
  779.                   obj_t initializers)
  780. {
  781.     struct thread *thread = thread_current();
  782.     obj_t *sp = thread->sp += 3;
  783.  
  784.     sp[-3] = inst_or_class;
  785.     sp[-2] = initargs;
  786.     do_initializers(thread, initializers);
  787.     go_on();
  788. }
  789.  
  790.  
  791. /* Defined Classes */
  792.  
  793. obj_t make_defined_class(obj_t debug_name, struct library *library)
  794. {
  795.     static int scav_instance(struct object *ptr);
  796.     static obj_t trans_instance(obj_t instance);
  797.  
  798.     obj_t res = alloc(obj_DefinedClassClass, sizeof(struct defined_class));
  799.  
  800.     init_class_type_stuff(res);
  801.     DC(res)->abstract_p = FALSE;
  802.     DC(res)->sealed_p = FALSE;
  803.     DC(res)->library = library;
  804.     DC(res)->scavenge = scav_instance;
  805.     DC(res)->transport = trans_instance;
  806.     DC(res)->print = NULL;
  807.     DC(res)->debug_name = debug_name;
  808.     DC(res)->superclasses = obj_False;
  809.     DC(res)->cpl = obj_False;
  810.     DC(res)->direct_subclasses = obj_Nil;
  811.     DC(res)->all_subclasses = obj_Nil;
  812.     DC(res)->new_slots = obj_False;
  813.     DC(res)->all_slots = obj_False;
  814.     DC(res)->new_initargs = obj_False;
  815.     DC(res)->all_initargs = obj_False;
  816.     DC(res)->inheriteds = obj_False;
  817.     DC(res)->instance_positions = obj_False;
  818.     DC(res)->instance_length = 0;
  819.     DC(res)->instance_layout = obj_False;
  820.     DC(res)->subclass_positions = obj_False;
  821.     DC(res)->subclass_slots = obj_False;
  822.     DC(res)->subclass_layout = obj_False;
  823.  
  824.     return res;
  825. }
  826.  
  827. static void compute_lengths(obj_t class)
  828. {
  829.     obj_t scan, slots, layout;
  830.     int instance_length = 0;
  831.     int subclass_length = 0;
  832.     int i;
  833.  
  834.     for (scan = TAIL(DC(class)->cpl); scan != obj_Nil; scan = TAIL(scan)) {
  835.     obj_t super = HEAD(scan);
  836.     if (obj_ptr(struct class *, super)->class == obj_DefinedClassClass) {
  837.         for (slots=DC(super)->new_slots;slots!=obj_Nil;slots=TAIL(slots)) {
  838.         switch (SD(HEAD(slots))->alloc) {
  839.           case alloc_INSTANCE:
  840.             instance_length++;
  841.             break;
  842.           case alloc_SUBCLASS:
  843.             subclass_length++;
  844.             break;
  845.           case alloc_CLASS:
  846.           case alloc_CONSTANT:
  847.           case alloc_VIRTUAL:
  848.             break;
  849.           default:
  850.             lose("Strange slot allocation.");
  851.         }
  852.         }
  853.     }
  854.     }
  855.  
  856.     for (slots = DC(class)->new_slots; slots != obj_Nil; slots = TAIL(slots)) {
  857.     obj_t slot = HEAD(slots);
  858.     switch (SD(slot)->alloc) {
  859.       case alloc_INSTANCE:
  860.         SD(slot)->desired_offset = instance_length++;
  861.         break;
  862.       case alloc_SUBCLASS:
  863.         SD(slot)->desired_offset = subclass_length++;
  864.         break;
  865.       case alloc_CLASS:
  866.       case alloc_CONSTANT:
  867.       case alloc_VIRTUAL:
  868.         break;
  869.       default:
  870.         lose("Strange slot allocation.");
  871.     }
  872.     }
  873.  
  874.     DC(class)->instance_length = instance_length;
  875.     layout = make_vector(instance_length, NULL);
  876.     DC(class)->instance_layout = layout;
  877.     for (i = 0; i < instance_length; i++)
  878.     SOVEC(layout)->contents[i] = obj_False;
  879.  
  880.     if (subclass_length > 0) {
  881.     obj_t slots = make_vector(subclass_length, NULL);
  882.     DC(class)->subclass_slots = slots;
  883.     layout = make_vector(subclass_length, NULL);
  884.     DC(class)->subclass_layout = layout;
  885.     for (i = 0; i < subclass_length; i++) {
  886.         SOVEC(layout)->contents[i] = obj_False;
  887.         SOVEC(slots)->contents[i] = obj_Unbound;
  888.     }
  889.     }
  890. }
  891.  
  892.  
  893. /* Process Slot Specifications */
  894.  
  895. static void add_slot(obj_t class, obj_t new_slot, boolean inherited)
  896. {
  897.     obj_t new_getter = SD(new_slot)->getter;
  898.     obj_t new_setter = SD(new_slot)->setter;
  899.     obj_t slots;
  900.  
  901.     for (slots = DC(class)->all_slots; slots != obj_Nil; slots = TAIL(slots)) {
  902.     obj_t slot = HEAD(slots);
  903.     obj_t getter = SD(slot)->getter;
  904.     obj_t setter = SD(slot)->setter;
  905.  
  906.     if (new_getter == getter)
  907.         if (inherited)
  908.         error("Can't inherit slot %= from both %= and %=",
  909.               function_debug_name_or_self(getter), SD(slot)->creator,
  910.               SD(new_slot)->creator);
  911.         else
  912.         error("Slot %= in %= clashes with the slot inherited from %=",
  913.               function_debug_name_or_self(getter), class,
  914.               SD(slot)->creator);
  915.     if (new_getter == setter)
  916.         if (inherited)
  917.         error("The getter for slot %= inherited from %= clashes with "
  918.               "the setter for slot %= inherited from %=",
  919.               function_debug_name_or_self(new_getter),
  920.               SD(new_slot)->creator,
  921.               function_debug_name_or_self(getter), SD(slot)->creator);
  922.         else
  923.         error("The getter for slot %= in %= clashes with "
  924.               "the setter for slot %= inherited from %=",
  925.               function_debug_name_or_self(new_getter), class,
  926.               function_debug_name_or_self(getter), SD(slot)->creator);
  927.     if (new_setter != obj_False) {
  928.         if (new_setter == getter)
  929.         if (inherited)
  930.             error("The setter for slot %= inherited from %= clashes "
  931.               "with the getter for slot %= inherited from %=",
  932.               function_debug_name_or_self(new_getter),
  933.               SD(new_slot)->creator,
  934.               function_debug_name_or_self(getter),
  935.               SD(slot)->creator);
  936.         else
  937.             error("The setter for slot %= in %= clashes "
  938.               "with the getter for slot %= inherited from %=",
  939.               function_debug_name_or_self(new_getter), class,
  940.               function_debug_name_or_self(getter),
  941.               SD(slot)->creator);
  942.         if (new_setter == setter)
  943.         if (inherited)
  944.             error("The setter for slot %= inherited from %= clashes "
  945.               "with the setter for slot %= inherited from %=",
  946.               function_debug_name_or_self(new_getter),
  947.               SD(new_slot)->creator,
  948.               function_debug_name_or_self(getter),
  949.               SD(slot)->creator);
  950.         else
  951.             error("The setter for slot %= in %= clashes "
  952.               "with the setter for slot %= inherited from %=",
  953.               function_debug_name_or_self(new_getter), class,
  954.               function_debug_name_or_self(getter),
  955.               SD(slot)->creator);
  956.     }
  957.     }
  958.  
  959.     DC(class)->all_slots = pair(new_slot, DC(class)->all_slots);
  960. }
  961.  
  962. static obj_t classes_processed;
  963. static obj_t displaced_instance_slots;
  964. static obj_t displaced_subclass_slots;
  965. static obj_t initializers;
  966.  
  967. static void inherit_slots(obj_t class, obj_t super)
  968. {
  969.     obj_t supers, new_slots;
  970.  
  971.     if (memq(super, classes_processed))
  972.     return;
  973.     classes_processed = pair(super, classes_processed);
  974.  
  975.     if (obj_ptr(struct class *, super)->class != obj_DefinedClassClass)
  976.     return;
  977.  
  978.     for (supers=DC(super)->superclasses; supers!=obj_Nil; supers=TAIL(supers))
  979.     inherit_slots(class, HEAD(supers));
  980.  
  981.     for (new_slots = DC(super)->new_slots;
  982.      new_slots != obj_Nil;
  983.      new_slots = TAIL(new_slots)) {
  984.     obj_t new_slot = HEAD(new_slots);
  985.  
  986.     add_slot(class, new_slot, TRUE);
  987.  
  988.     switch (SD(new_slot)->alloc) {
  989.         int offset;
  990.       case alloc_INSTANCE:
  991.         offset = SD(new_slot)->desired_offset;
  992.         if (SOVEC(DC(class)->instance_layout)->contents[offset]
  993.           != obj_False)
  994.         displaced_instance_slots
  995.             = pair(new_slot, displaced_instance_slots);
  996.         else
  997.         SOVEC(DC(class)->instance_layout)->contents[offset] = new_slot;
  998.         break;
  999.  
  1000.       case alloc_SUBCLASS:
  1001.         offset = SD(new_slot)->desired_offset;
  1002.         if (SOVEC(DC(class)->subclass_layout)->contents[offset]
  1003.           != obj_False)
  1004.         displaced_subclass_slots
  1005.             = pair(new_slot, displaced_subclass_slots);
  1006.         else {
  1007.         SOVEC(DC(class)->subclass_layout)->contents[offset] = new_slot;
  1008.         initializers = pair(slot_initializer(new_slot), initializers);
  1009.         }
  1010.         break;
  1011.  
  1012.       case alloc_CLASS:
  1013.       case alloc_CONSTANT:
  1014.       case alloc_VIRTUAL:
  1015.         /* We don't need to do anything to inherit these. */
  1016.         break;
  1017.  
  1018.       default:
  1019.         lose("Strange slot allocation.");
  1020.     }
  1021.     }
  1022. }
  1023.  
  1024. static obj_t compute_positions(obj_t displaced_slots, obj_t layout)
  1025. {
  1026.     int index = 0;
  1027.     obj_t res;
  1028.  
  1029.     if (displaced_slots == obj_Nil)
  1030.     return obj_False;
  1031.  
  1032.     res = make_position_table();
  1033.     while (displaced_slots != obj_Nil) {
  1034.     obj_t slot = HEAD(displaced_slots);
  1035.     while (SOVEC(layout)->contents[index] != obj_False)
  1036.         index++;
  1037.     SOVEC(layout)->contents[index] = slot;
  1038.     note_position(res, slot, index);
  1039.     displaced_slots = TAIL(displaced_slots);
  1040.     }
  1041.  
  1042.     return res;
  1043. }
  1044.  
  1045. static void process_slot(obj_t class, obj_t slot)
  1046. {
  1047.     int offset = SD(slot)->desired_offset;
  1048.     obj_t value_cell;
  1049.  
  1050.     SD(slot)->creator = class;
  1051.  
  1052.     add_slot(class, slot, FALSE);
  1053.  
  1054.     switch (SD(slot)->alloc) {
  1055.       case alloc_INSTANCE:
  1056.     SOVEC(DC(class)->instance_layout)->contents[offset] = slot;
  1057.     SD(slot)->getter_method
  1058.         = make_accessor_method(function_debug_name(SD(slot)->getter),
  1059.                    class, SD(slot)->type,
  1060.                    FALSE, make_fixnum(offset),
  1061.                    fast_instance_getter);
  1062.     add_method(SD(slot)->getter, SD(slot)->getter_method);
  1063.     if (SD(slot)->setter != obj_False) {
  1064.         SD(slot)->setter_method
  1065.         = make_accessor_method(function_debug_name(SD(slot)->setter),
  1066.                        class, SD(slot)->type,
  1067.                        TRUE, make_fixnum(offset),
  1068.                        fast_instance_setter);
  1069.         add_method(SD(slot)->setter, SD(slot)->setter_method);
  1070.     }
  1071.     break;
  1072.  
  1073.       case alloc_SUBCLASS:
  1074.     SOVEC(DC(class)->subclass_layout)->contents[offset] = slot;
  1075.     initializers = pair(slot_initializer(slot), initializers);
  1076.     SD(slot)->getter_method
  1077.         = make_accessor_method(function_debug_name(SD(slot)->getter),
  1078.                    class, SD(slot)->type,
  1079.                    FALSE, make_fixnum(offset),
  1080.                    fast_subclass_getter);
  1081.     add_method(SD(slot)->getter, SD(slot)->getter_method);
  1082.     if (SD(slot)->setter != obj_False) {
  1083.         SD(slot)->setter_method
  1084.         = make_accessor_method(function_debug_name(SD(slot)->setter),
  1085.                        class, SD(slot)->type, TRUE,
  1086.                        make_fixnum(offset),
  1087.                        fast_subclass_setter);
  1088.         add_method(SD(slot)->setter, SD(slot)->setter_method);
  1089.     }
  1090.     break;
  1091.  
  1092.       case alloc_CLASS:
  1093.     value_cell = make_value_cell(obj_Unbound);
  1094.     initializers = pair(slot_initializer(slot), initializers);
  1095.     SD(slot)->getter_method
  1096.         = make_accessor_method(function_debug_name(SD(slot)->getter),
  1097.                    class, SD(slot)->type,
  1098.                    FALSE, value_cell, class_getter);
  1099.     add_method(SD(slot)->getter, SD(slot)->getter_method);
  1100.     if (SD(slot)->setter != obj_False) {
  1101.         SD(slot)->setter_method
  1102.         = make_accessor_method(function_debug_name(SD(slot)->setter),
  1103.                        class, SD(slot)->type,
  1104.                        TRUE, value_cell, class_setter);
  1105.         add_method(SD(slot)->setter, SD(slot)->setter_method);
  1106.     }
  1107.     break;
  1108.  
  1109.       case alloc_CONSTANT:
  1110.     SD(slot)->getter_method
  1111.         = make_accessor_method(function_debug_name(SD(slot)->getter),
  1112.                    class, SD(slot)->type,
  1113.                    FALSE, SD(slot)->init_function_or_value,
  1114.                    constant_getter);
  1115.     add_method(SD(slot)->getter, SD(slot)->getter_method);
  1116.     break;
  1117.  
  1118.       case alloc_VIRTUAL:
  1119.     /* Don't need to add any methods. */
  1120.     break;
  1121.  
  1122.       default:
  1123.     lose("Strange slot allocation.");
  1124.     }
  1125. }
  1126.  
  1127.  
  1128. /* Process Initarg Specifications */
  1129.  
  1130. #define conflicting_initargs(initarg1, initarg2) \
  1131.     (INTD(initarg1)->type != INTD(initarg2)->type \
  1132.      || INTD(initarg1)->required_p != INTD(initarg2)->required_p \
  1133.      || INTD(initarg1)->init_function_or_value \
  1134.        != INTD(initarg2)->init_function_or_value)
  1135.  
  1136. static void inherit_initargs(obj_t class, obj_t super)
  1137. {
  1138.     obj_t inh_initargs;
  1139.     obj_t new_initargs;
  1140.     obj_t all_initargs;
  1141.  
  1142.     if (obj_ptr(struct class *, super)->class != obj_DefinedClassClass)
  1143.         return;
  1144.  
  1145.     for (inh_initargs = DC(super)->new_initargs; inh_initargs != obj_Nil;
  1146.      inh_initargs = TAIL(inh_initargs)) {
  1147.     obj_t inh_initarg = HEAD(inh_initargs);
  1148.     boolean redefined = FALSE;
  1149.     boolean inherited = FALSE;
  1150.  
  1151.     for (new_initargs = DC(class)->new_initargs; new_initargs != obj_Nil;
  1152.          new_initargs = TAIL(new_initargs)) {
  1153.         obj_t initarg = HEAD(new_initargs);
  1154.  
  1155.         if (INTD(inh_initarg)->keyword == INTD(initarg)->keyword) {
  1156.         /* Check that the type is a subtype of the inherited */
  1157.         if (!subtypep(INTD(initarg)->type, INTD(inh_initarg)->type))
  1158.             error("Incompatible init arg type for %=.",
  1159.               INTD(initarg)->keyword);
  1160.         /* Determine whether initarg is required */
  1161.         if (INTD(inh_initarg)->required_p
  1162.               && INTD(initarg)->init_function_or_value == obj_Unbound)
  1163.             INTD(initarg)->required_p = TRUE;
  1164.         redefined = TRUE;
  1165.         break;
  1166.         }
  1167.     }
  1168.     if (redefined)
  1169.         break;
  1170.     for (all_initargs = DC(class)->all_initargs; all_initargs != obj_Nil;
  1171.          all_initargs = TAIL(all_initargs)) {
  1172.         obj_t initarg = HEAD(all_initargs);
  1173.  
  1174.         if (INTD(inh_initarg)->keyword == INTD(initarg)->keyword) {
  1175.         /* Determine whether definitions are the same */
  1176.         if (conflicting_initargs(inh_initarg, initarg))
  1177.             error("Conflicting inherited definitions of init arg %=",
  1178.               INTD(initarg)->keyword);
  1179.         inherited = TRUE;
  1180.         }
  1181.     }
  1182.     if (!redefined && !inherited) {
  1183.         DC(class)->all_initargs =
  1184.           pair(inh_initarg, DC(class)->all_initargs);
  1185.     }
  1186.     }
  1187. }
  1188.  
  1189.  
  1190. /* Process Inherited Specifications */
  1191.  
  1192. static void process_inherited(obj_t class, obj_t inherited)
  1193. {
  1194.     obj_t slots;
  1195.  
  1196.     for (slots = DC(class)->all_slots; slots != obj_Nil; slots = TAIL(slots)) {
  1197.     obj_t slot = HEAD(slots);
  1198.     obj_t inits;
  1199.  
  1200.     if (SD(slot)->name == INHD(inherited)->name) {
  1201.         switch (SD(slot)->alloc) {
  1202.           case alloc_INSTANCE:
  1203.         break;
  1204.           case alloc_SUBCLASS:
  1205.         for (inits = initializers; inits != obj_Nil;
  1206.              inits = TAIL(inits)) {
  1207.             obj_t init = HEAD(inits);
  1208.  
  1209.             if (INITIALIZER(init)->slot == slot) {
  1210.                 HEAD(inits) = inherited_initializer(slot, inherited);
  1211.             break;
  1212.             }
  1213.         }
  1214.         if (inits == obj_Nil) {
  1215.             initializers
  1216.               = pair(inherited_initializer(slot, inherited),
  1217.                  initializers);
  1218.         }
  1219.         break;
  1220.           case alloc_CLASS:
  1221.           case alloc_CONSTANT:
  1222.           case alloc_VIRTUAL:
  1223.         if (INHD(inherited)->init_function_or_value != obj_Unbound)
  1224.             error("Can't init inherited slot %=",
  1225.               INHD(inherited)->name);
  1226.         break;
  1227.           default:
  1228.         lose("Strange slot allocation.");
  1229.         }
  1230.         return;
  1231.     }
  1232.     }
  1233.     error("Slot %= not inherited from any superclass",
  1234.       INHD(inherited)->name);
  1235. }
  1236.  
  1237.  
  1238. /* Initialize Defined Class */
  1239.  
  1240. void init_defined_class(obj_t class, obj_t slots,
  1241.             obj_t initargs, obj_t inheriteds)
  1242. {
  1243.     obj_t scan;
  1244.  
  1245.     DC(class)->new_slots = slots;
  1246.     DC(class)->all_slots = obj_Nil;
  1247.     DC(class)->new_initargs = initargs;
  1248.     DC(class)->all_initargs = initargs;
  1249.     DC(class)->inheriteds = inheriteds;
  1250.  
  1251.     compute_lengths(class);
  1252.  
  1253.     /* Process Slots */
  1254.  
  1255.     classes_processed = obj_Nil;
  1256.     displaced_instance_slots = obj_Nil;
  1257.     displaced_subclass_slots = obj_Nil;
  1258.     initializers = obj_Nil;
  1259.  
  1260.     for (scan = DC(class)->superclasses; scan != obj_Nil; scan = TAIL(scan))
  1261.     inherit_slots(class, HEAD(scan));
  1262.  
  1263.     DC(class)->instance_positions
  1264.     = compute_positions(displaced_instance_slots,
  1265.                 DC(class)->instance_layout);
  1266.     DC(class)->subclass_positions
  1267.     = compute_positions(displaced_subclass_slots,
  1268.                 DC(class)->subclass_layout);
  1269.  
  1270.     classes_processed = NULL;
  1271.     displaced_instance_slots = NULL;
  1272.     displaced_subclass_slots = NULL;
  1273.  
  1274.     for (scan = slots; scan != obj_Nil; scan = TAIL(scan))
  1275.     process_slot(class, HEAD(scan));
  1276.  
  1277.     /* Process Initargs */
  1278.  
  1279.     for (scan = TAIL(DC(class)->cpl); scan != obj_Nil; scan = TAIL(scan))
  1280.     inherit_initargs(class, HEAD(scan));
  1281.  
  1282.     /* Process Inheriteds */
  1283.  
  1284.     for (scan = inheriteds; scan != obj_Nil; scan = TAIL(scan))
  1285.         process_inherited(class, HEAD(scan));
  1286.  
  1287.     scan = initializers;
  1288.     initializers = NULL;
  1289.     do_initialization(class, obj_Nil, scan);
  1290. }
  1291.     
  1292.  
  1293. /* Make and Initialize Instances */
  1294.  
  1295. static obj_t dylan_make(obj_t class, obj_t key_and_value_pairs)
  1296. {
  1297.     error("Can't make instances of %= with the default make method.",
  1298.       class);
  1299.     return NULL;
  1300. }
  1301.  
  1302. static obj_t defaulted_initargs(obj_t class, obj_t keyword_arg_pairs)
  1303. {
  1304.     int i;
  1305.     int nkeys = SOVEC(keyword_arg_pairs)->length;
  1306.     obj_t supplied_initargs = obj_Nil;
  1307.     obj_t defaulted_initargs;
  1308.     obj_t supplieds;
  1309.     obj_t initargs;
  1310.  
  1311.     /* Get the supplied initialization arguments */
  1312.  
  1313.     for (i = 0; i < nkeys; i += 2) {
  1314.     obj_t initarg =
  1315.       make_initarg_descr(SOVEC(keyword_arg_pairs)->contents[i],
  1316.                  obj_False, obj_False, obj_Unbound,
  1317.                  SOVEC(keyword_arg_pairs)->contents[i+1]);
  1318.     supplied_initargs = pair(initarg, supplied_initargs);
  1319.     }
  1320.  
  1321.     /* Augment supplied initialization arguments with defaults */
  1322.  
  1323.     defaulted_initargs = supplied_initargs;
  1324.  
  1325.     for (initargs = DC(class)->all_initargs; initargs != obj_Nil;
  1326.      initargs = TAIL(initargs)) {
  1327.     obj_t initarg = HEAD(initargs);
  1328.     boolean found = FALSE;
  1329.  
  1330.     for (supplieds = supplied_initargs; supplieds != obj_Nil;
  1331.          supplieds = TAIL(supplieds)) {
  1332.         obj_t supplied = HEAD(supplieds);
  1333.  
  1334.         if (INTD(initarg)->keyword == INTD(supplied)->keyword) {
  1335.         if (!instancep(INTD(supplied)->init_function_or_value,
  1336.                    INTD(initarg)->type))
  1337.             error("Keyword arg %= must have type %=",
  1338.               INTD(initarg)->keyword, INTD(initarg)->type);
  1339.             found = TRUE;
  1340.         break;
  1341.         }
  1342.     }
  1343.     if (!found) {
  1344.         if (INTD(initarg)->required_p)
  1345.             error("Required init arg %= not supplied",
  1346.               INTD(initarg)->keyword);
  1347.         else
  1348.         defaulted_initargs = pair(initarg, defaulted_initargs);
  1349.     }
  1350.     }
  1351.     return defaulted_initargs;
  1352. }
  1353.  
  1354. static obj_t dylan_make_instance(obj_t class, obj_t keyword_arg_pairs)
  1355. {
  1356.     obj_t res = alloc(class, sizeof(struct instance)
  1357.                        + DC(class)->instance_length * sizeof(obj_t));
  1358.     obj_t default_initargs;
  1359.     obj_t slots;
  1360.     obj_t initargs;
  1361.     obj_t inits;
  1362.  
  1363.     if (DC(class)->all_slots == obj_False)
  1364.     error("Attempt to make an instance of %= before\n"
  1365.           "the define class for it has been processed.",
  1366.           class);
  1367.  
  1368.     initializers = obj_Nil;
  1369.  
  1370.     default_initargs = defaulted_initargs(class, keyword_arg_pairs);
  1371.  
  1372.     for (slots = DC(class)->all_slots; slots != obj_Nil; slots = TAIL(slots)) {
  1373.     obj_t slot = HEAD(slots);
  1374.     boolean slot_initialized_p = FALSE;
  1375.     obj_t keyword = SD(slot)->init_keyword;
  1376.  
  1377.     /* Check for keyword init value */
  1378.  
  1379.     if (keyword != obj_False && !slot_initialized_p) {
  1380.         obj_t initargs;
  1381.         boolean suppliedp = FALSE;
  1382.  
  1383.         for (initargs = default_initargs; initargs != obj_Nil;
  1384.          initargs = TAIL(initargs)) {
  1385.         obj_t initarg = HEAD(initargs);
  1386.  
  1387.         if (INTD(initarg)->keyword == keyword) {
  1388.             obj_t initializer
  1389.               = initarg_slot_initializer(slot, initarg);
  1390.  
  1391.             INTD(initarg)->initializer = initializer;
  1392.             initializers = pair(initializer, initializers);
  1393.             slot_initialized_p = TRUE;
  1394.             suppliedp = TRUE;
  1395.             break;
  1396.         }
  1397.         }
  1398.         if (SD(slot)->keyword_required && !suppliedp)
  1399.         error("Missing required init-keyword %=", keyword);
  1400.     }
  1401.  
  1402.     /* Check for inherited spec init value */
  1403.  
  1404.     if (!slot_initialized_p) {
  1405.         obj_t inheriteds;
  1406.  
  1407.         for (inheriteds = DC(class)->inheriteds; inheriteds != obj_Nil;
  1408.          inheriteds = TAIL(inheriteds)) {
  1409.         obj_t inherited = HEAD(inheriteds);
  1410.         
  1411.         if (SD(slot)->name == INHD(inherited)->name
  1412.               && SD(slot)->alloc == alloc_INSTANCE) {
  1413.             obj_t initializer
  1414.               = inherited_initializer(slot, inherited);
  1415.  
  1416.             initializers = pair(initializer, initializers);
  1417.             slot_initialized_p = TRUE;
  1418.             break;
  1419.         }
  1420.         }
  1421.     }
  1422.  
  1423.     /* Check for slot spec init value */
  1424.  
  1425.     if (!slot_initialized_p && SD(slot)->alloc == alloc_INSTANCE) {
  1426.         obj_t initializer = slot_initializer(slot);
  1427.  
  1428.         initializers = pair(initializer, initializers);
  1429.         slot_initialized_p = TRUE;
  1430.     }
  1431.     }
  1432.  
  1433.     for (initargs = default_initargs; initargs != obj_Nil;
  1434.      initargs = TAIL(initargs)) {
  1435.     obj_t initarg = HEAD(initargs);
  1436.  
  1437.     if (INTD(initarg)->initializer == obj_False) {
  1438.         obj_t initializer = initarg_initializer(initarg);
  1439.  
  1440.         INTD(initarg)->initializer = initializer;
  1441.         initializers = pair(initializer, initializers);
  1442.     }
  1443.     }
  1444.  
  1445.     inits = initializers;
  1446.     initializers = NULL;
  1447.     do_initialization(res, default_initargs, inits);
  1448.  
  1449.     return NULL;
  1450. }
  1451.  
  1452. static obj_t dylan_init(obj_t object, obj_t key_val_pairs)
  1453. {
  1454.     return obj_False;
  1455. }
  1456.  
  1457.  
  1458.  
  1459. /* Other routines. */
  1460.  
  1461. static obj_t dylan_slot_initialized_p(obj_t instance, obj_t getter)
  1462. {
  1463.     obj_t class = object_class(instance);
  1464.     obj_t scan, slot;
  1465.     int index;
  1466.     obj_t value = NULL;
  1467.  
  1468.     if (object_class(class) != obj_DefinedClassClass)
  1469.     error("%= doesn't access a slot in %=", getter, instance);
  1470.  
  1471.     for (scan = DC(class)->all_slots; scan != obj_Nil; scan = TAIL(scan)) {
  1472.     slot = HEAD(scan);
  1473.     if (SD(slot)->getter == getter) {
  1474.         switch (SD(slot)->alloc) {
  1475.           case alloc_INSTANCE:
  1476.         index = find_position(DC(class)->instance_positions, slot);
  1477.         value = INST(instance)->slots[index];
  1478.         break;
  1479.           case alloc_SUBCLASS:
  1480.         index = find_position(DC(class)->subclass_positions, slot);
  1481.         value = INST(instance)->slots[index];
  1482.         break;
  1483.           case alloc_CLASS:
  1484.         value = value_cell_ref(accessor_method_datum
  1485.                        (SD(slot)->getter_method));
  1486.         break;
  1487.           case alloc_CONSTANT:
  1488.         value = accessor_method_datum(SD(slot)->getter_method);
  1489.         break;
  1490.           case alloc_VIRTUAL:
  1491.         value = obj_False;
  1492.         break;
  1493.           default:
  1494.         lose("Strange slot allocation.");
  1495.         }
  1496.         if (value == obj_Unbound)
  1497.         return obj_False;
  1498.         else
  1499.         return obj_True;
  1500.     }
  1501.     }
  1502.  
  1503.     error("%= doesn't access a slot in %=", getter, instance);    
  1504.     return NULL;
  1505. }
  1506.  
  1507.  
  1508. /* Describe. */
  1509.  
  1510. void describe(obj_t thing)
  1511. {
  1512.     obj_t class = object_class(thing);
  1513.     obj_t slots;
  1514.  
  1515.     prin1(thing);
  1516.     printf(" is an instance of ");
  1517.     print(class);
  1518.  
  1519.     if (object_class(class) == obj_DefinedClassClass) {
  1520.     printf("and has the following slots:\n");
  1521.  
  1522.     for (slots=DC(class)->all_slots; slots != obj_Nil; slots=TAIL(slots)) {
  1523.         obj_t slot = HEAD(slots);
  1524.         int index;
  1525.         obj_t value;
  1526.  
  1527.         prin1(SD(slot)->name);
  1528.         switch (SD(slot)->alloc) {
  1529.           case alloc_INSTANCE:
  1530.         index = find_position(DC(class)->instance_positions, slot);
  1531.         value = INST(thing)->slots[index];
  1532.         break;
  1533.           case alloc_SUBCLASS:
  1534.         printf("[each subclass]");
  1535.         index = find_position(DC(class)->subclass_positions, slot);
  1536.         value = INST(thing)->slots[index];
  1537.         break;
  1538.           case alloc_CLASS:
  1539.         value = value_cell_ref(accessor_method_datum
  1540.                        (SD(slot)->getter_method));
  1541.         printf("[class]");
  1542.         break;
  1543.           case alloc_CONSTANT:
  1544.         value = accessor_method_datum(SD(slot)->getter_method);
  1545.         printf("[constant]");
  1546.         break;
  1547.           case alloc_VIRTUAL:
  1548.         printf("[virtual]\n");
  1549.         goto after_value_printing;
  1550.           default:
  1551.         lose("Strange slot allocation.");
  1552.         }
  1553.  
  1554.         if (value == obj_Unbound)
  1555.         printf(" is unbound\n");
  1556.         else {
  1557.         printf(": ");
  1558.         print(value);
  1559.         }
  1560.       after_value_printing:
  1561.     }
  1562.     }
  1563. }
  1564.  
  1565.  
  1566. /* GC routines. */
  1567.  
  1568. static int scav_defined_class(struct object *ptr)
  1569. {
  1570.     struct defined_class *class = (struct defined_class *)ptr;
  1571.  
  1572.     scavenge(&class->debug_name);
  1573.     scavenge(&class->superclasses);
  1574.     scavenge(&class->cpl);
  1575.     scavenge(&class->direct_subclasses);
  1576.     scavenge(&class->all_subclasses);
  1577.     scavenge(&class->new_slots);
  1578.     scavenge(&class->all_slots);
  1579.     scavenge(&class->new_initargs);
  1580.     scavenge(&class->all_initargs);
  1581.     scavenge(&class->inheriteds);
  1582.     scavenge(&class->instance_positions);
  1583.     scavenge(&class->instance_layout);
  1584.     scavenge(&class->subclass_positions);
  1585.     scavenge(&class->subclass_slots);
  1586.     scavenge(&class->subclass_layout);
  1587.  
  1588.     return sizeof(struct defined_class);
  1589. }
  1590.  
  1591. static obj_t trans_defined_class(obj_t class)
  1592. {
  1593.     return transport(class, sizeof(struct defined_class));
  1594. }
  1595.  
  1596. static int scav_slot_descr(struct object *ptr)
  1597. {
  1598.     struct slot_descr *slot = (struct slot_descr *)ptr;
  1599.  
  1600.     scavenge(&slot->name);
  1601.     scavenge(&slot->creator);
  1602.     scavenge(&slot->init_function_or_value);
  1603.     scavenge(&slot->init_keyword);
  1604.     scavenge(&slot->getter);
  1605.     scavenge(&slot->getter_method);
  1606.     scavenge(&slot->setter);
  1607.     scavenge(&slot->setter_method);
  1608.     scavenge(&slot->type);
  1609.  
  1610.     return sizeof(struct slot_descr);
  1611. }
  1612.  
  1613. static obj_t trans_slot_descr(obj_t slot)
  1614. {
  1615.     return transport(slot, sizeof(struct slot_descr));
  1616. }
  1617.  
  1618. static int scav_initarg_descr(struct object *ptr)
  1619. {
  1620.     struct initarg_descr *initarg = (struct initarg_descr *)ptr;
  1621.  
  1622.     scavenge(&initarg->keyword);
  1623.     scavenge(&initarg->type);
  1624.     scavenge(&initarg->init_function_or_value);
  1625.  
  1626.     return sizeof(struct initarg_descr);
  1627. }
  1628.  
  1629. static obj_t trans_initarg_descr(obj_t initarg)
  1630. {
  1631.     return transport(initarg, sizeof(struct initarg_descr));
  1632. }
  1633.  
  1634. static int scav_inherited_descr(struct object *ptr)
  1635. {
  1636.     struct inherited_descr *inherited = (struct inherited_descr *)ptr;
  1637.  
  1638.     scavenge(&inherited->name);
  1639.     scavenge(&inherited->init_function_or_value);
  1640.  
  1641.     return sizeof(struct inherited_descr);
  1642. }
  1643.  
  1644. static obj_t trans_inherited_descr(obj_t inherited)
  1645. {
  1646.     return transport(inherited, sizeof(struct inherited_descr));
  1647. }
  1648.  
  1649. static int scav_postable(struct object *ptr)
  1650. {
  1651.     struct postable *p = (struct postable *)ptr;
  1652.  
  1653.     scavenge(&p->alist);
  1654.  
  1655.     return sizeof(struct postable);
  1656. }
  1657.  
  1658. static obj_t trans_postable(obj_t p)
  1659. {
  1660.     return transport(p, sizeof(struct postable));
  1661. }
  1662.  
  1663. static int scav_initializer(struct object *ptr)
  1664. {
  1665.     struct initializer *p = (struct initializer *)ptr;
  1666.  
  1667.     scavenge(&p->slot);
  1668.     scavenge(&p->initarg);
  1669.     scavenge(&p->inherited);
  1670.  
  1671.     return sizeof(struct initializer);
  1672. }
  1673.  
  1674. static obj_t trans_initializer(obj_t p)
  1675. {
  1676.     return transport(p, sizeof(struct initializer));
  1677. }
  1678.  
  1679. static int scav_instance(struct object *ptr)
  1680. {
  1681.     struct instance *instance = (struct instance *)ptr;
  1682.     int nslots = DC(ptr->class)->instance_length;
  1683.     int i;
  1684.  
  1685.     for (i = 0; i < nslots; i++)
  1686.     scavenge(instance->slots + i);
  1687.  
  1688.     return sizeof(struct instance) + nslots*sizeof(obj_t);
  1689. }
  1690.  
  1691. static obj_t trans_instance(obj_t instance)
  1692. {
  1693.     obj_t class = INST(instance)->class;
  1694.     int nslots = DC(class)->instance_length;
  1695.  
  1696.     return transport(instance, sizeof(struct instance) + nslots*sizeof(obj_t));
  1697. }
  1698.  
  1699. void scavenge_instance_roots(void)
  1700. {
  1701.     scavenge(&obj_DefinedClassClass);
  1702.     scavenge(&obj_SlotDescrClass);
  1703.     scavenge(&obj_InitargDescrClass);
  1704.     scavenge(&obj_InheritedDescrClass);
  1705.     scavenge(&obj_PosTableClass);
  1706.     scavenge(&obj_InitializerClass);
  1707. }
  1708.  
  1709. /* Init stuff. */
  1710.  
  1711. void make_instance_classes(void)
  1712. {
  1713.     obj_DefinedClassClass
  1714.     = make_builtin_class(scav_defined_class, trans_defined_class);
  1715.     obj_SlotDescrClass = make_builtin_class(scav_slot_descr, trans_slot_descr);
  1716.     obj_InitargDescrClass =
  1717.       make_builtin_class(scav_initarg_descr, trans_initarg_descr);
  1718.     obj_InheritedDescrClass =
  1719.       make_builtin_class(scav_inherited_descr, trans_inherited_descr);
  1720.     obj_PosTableClass = make_builtin_class(scav_postable, trans_postable);
  1721.     obj_InitializerClass =
  1722.       make_builtin_class(scav_initializer, trans_initializer);
  1723. }
  1724.  
  1725. void init_instance_classes(void)
  1726. {
  1727.     init_builtin_class(obj_DefinedClassClass, "<defined-class>",
  1728.                obj_ClassClass, NULL);
  1729.     init_builtin_class(obj_SlotDescrClass, "<slot-descriptor>",
  1730.                obj_ObjectClass, NULL);
  1731.     init_builtin_class(obj_InitargDescrClass, "<initarg-descriptor>",
  1732.                obj_ObjectClass, NULL);
  1733.     init_builtin_class(obj_InheritedDescrClass, "<inherited-descriptor>",
  1734.                obj_ObjectClass, NULL);
  1735.     init_builtin_class(obj_PosTableClass, "<position-table>",
  1736.                obj_ObjectClass, NULL);
  1737.     init_builtin_class(obj_InitializerClass, "<initializer>",
  1738.                obj_ObjectClass, NULL);
  1739. }
  1740.  
  1741. void init_instance_functions(void)
  1742. {
  1743.     obj_t obj_FalseClass = object_class(obj_False);
  1744.  
  1745.     define_function("make-slot",
  1746.             listn(5, obj_ObjectClass, obj_IntegerClass,
  1747.               obj_FunctionClass,
  1748.               type_union(obj_FunctionClass, obj_FalseClass),
  1749.               type_union(obj_TypeClass, obj_FalseClass)),
  1750.             FALSE,
  1751.             listn(4, pair(symbol("init-keyword"), obj_False),
  1752.               pair(symbol("required-init-keyword"), obj_False),
  1753.               pair(symbol("init-function"), obj_Unbound),
  1754.               pair(symbol("init-value"), obj_Unbound)),
  1755.             FALSE, obj_SlotDescrClass, make_slot_descriptor);
  1756.     define_function("make-initarg",
  1757.             list2(obj_ObjectClass, obj_ObjectClass),
  1758.             FALSE,
  1759.             list3(pair(symbol("type"), obj_False),
  1760.               pair(symbol("init-function"), obj_Unbound),
  1761.               pair(symbol("init-value"), obj_Unbound)),
  1762.             FALSE, obj_InitargDescrClass, make_initarg_descr);
  1763.     define_function("make-inherited",
  1764.             list1(obj_ObjectClass),
  1765.             FALSE,
  1766.             list2(pair(symbol("init-function"), obj_Unbound),
  1767.               pair(symbol("init-value"), obj_Unbound)),
  1768.             FALSE, obj_InheritedDescrClass, make_inherited_descr);
  1769.     define_generic_function("make", 1, FALSE, obj_Nil, TRUE,
  1770.                 obj_Nil, obj_ObjectClass);
  1771.     define_method("make", list1(obj_ClassClass), TRUE, obj_Nil, FALSE,
  1772.           obj_ObjectClass, dylan_make);
  1773.     define_method("make", list1(obj_DefinedClassClass), TRUE, obj_Nil, FALSE,
  1774.           obj_ObjectClass, dylan_make_instance);
  1775.     define_generic_function("initialize", 1, FALSE, obj_Nil, TRUE,
  1776.                 obj_Nil, obj_ObjectClass);
  1777.     define_method("initialize", list1(obj_ObjectClass), TRUE, obj_Nil, FALSE,
  1778.           obj_ObjectClass, dylan_init);
  1779.     initialize_gf_variable =
  1780.       find_variable(module_BuiltinStuff, symbol("initialize"), FALSE, TRUE);
  1781.     define_method("slot-initialized?",
  1782.           list2(obj_ObjectClass, obj_FunctionClass),
  1783.           FALSE, obj_Nil, FALSE, obj_BooleanClass,
  1784.           dylan_slot_initialized_p);
  1785. }
  1786.